home *** CD-ROM | disk | FTP | other *** search
/ NeXT Education Software Sampler 1992 Fall / NeXT Education Software Sampler 1992 Fall.iso / Mathematics / Notebooks / SigProc2.0 / Packages / SignalProcessing / ObjectOriented / Heuristics.m next >
Encoding:
Text File  |  1992-08-18  |  7.0 KB  |  237 lines
  1. (*  :Title:    Heuristic Application of Rules  *)
  2.  
  3. (*  :Authors:    Brian Evans, James McClellan  *)
  4.  
  5. (*
  6.     :Summary:    To provide heuristics for the intelligent application
  7.         of rules involved in one-to-many transformation a la
  8.         Covell.
  9.  *)
  10.  
  11. (*  :Context:    SignalProcessing`ObjectOriented`RewriteRules`  *)
  12.  
  13. (*  :PackageVersion:  2.7    *)
  14.  
  15. (*
  16.     :Copyright:    Copyright 1989-1991 by Brian L. Evans
  17.         Georgia Tech Research Corporation
  18.  
  19.     Permission to use, copy, modify, and distribute this software
  20.     and its documentation for any purpose and without fee is
  21.     hereby granted, provided that the above copyright notice
  22.     appear in all copies and that both that copyright notice and
  23.     this permission notice appear in supporting documentation,
  24.     and that the name of the Georgia Tech Research Corporation,
  25.     Georgia Tech, or Georgia Institute of Technology not be used
  26.     in advertising or publicity pertaining to distribution of the
  27.     software without specific, written prior permission.  Georgia
  28.     Tech makes no representations about the suitability of this
  29.     software for any purpose.  It is provided "as is" without
  30.     express or implied warranty.
  31.  *)
  32.  
  33. (*  :History:    *)
  34.  
  35. (*  :Keywords:    *)
  36.  
  37. (*
  38.     :Source:    M. M. Covell.  {An Algorithm Design Environment for
  39.           Signal Processing}.  M.I.T. Ph. D. Thesis.  December,
  40.           1989.
  41.  
  42.         C. S. Myers.  {Signal Representation for Symbolic and
  43.           Numeric Processing}.  M.I.T. Ph. D. Thesis.  August,
  44.           1986.  Appendix D.
  45.  *)
  46.  
  47. (*  :Warning:    *)
  48.  
  49. (*  :Mathematica Version:  1.2 or 2.0  *)
  50.  
  51. (*  :Limitation:  *)
  52.  
  53. (*
  54.     :Discussion:  The blind application of a set of rewrite rules to
  55.           an entire expression will cause a combinatoric
  56.           explosion of equivalent forms.  Therefore, it is
  57.           desirable to apply them in an intelligent or
  58.           heuristic manner.
  59.  *)
  60.  
  61. (*  :Functions:     *)
  62.  
  63.  
  64.  
  65. (*  B E G I N     P A C K A G E  *)
  66.  
  67.  
  68. BeginPackage[ "SignalProcessing`ObjectOriented`Heuristic`",
  69.           "SignalProcessing`Support`Tree`",
  70.           "SignalProcessing`Support`SupCode`" ]
  71.  
  72.  
  73. If [ TrueQ[ $VersionNumber >= 2.0 ],
  74.      Off[ General::spell ];
  75.      Off[ General::spell1 ] ];
  76.  
  77.  
  78. (*  U S A G E     I N F O R M A T I O N  *)
  79.  
  80. SPHeuristicRewrite::usage =
  81.     "SPHeuristicRewrite[expr, rules] tries to rewrite expressions \
  82.     on the same level of expr together using the list of rules."
  83.  
  84. SPRecursiveRewrite::usage =
  85.     "SPRecursiveRewrite[expr, rules] only returns a fully rewritten \
  86.     version of the signal processing expression expr. \
  87.     The Rewrite knowledge base is let loose on the expression expr \
  88.     without any guidance. \
  89.     The user can see the intermediate expressions by setting the \
  90.     Dialogue option to True or False."
  91.  
  92. (*  E N D     U S A G E     I N F O R M A T I O N  *)
  93.  
  94.  
  95. Begin[ "`Private`" ]
  96.  
  97.  
  98. (*  B L I N D L Y     A P P L Y I N G     R E W R I T E     R U L E S  *)
  99.  
  100. (*  The Rewrite rules base can be driven by several routines.  *)
  101.  
  102. (*  Recursive Rewrite rules or when all else fails    *)
  103. (*    op_[p__][args__] :> op[p] [ f[args] ] ,        *)
  104. (*    op_[p__] :> op[p] ,                *)
  105.  
  106. SPRecursiveRewrite::badrec =
  107.     "The MaxRecursion option is not set to a positive integer"
  108.  
  109. Options[ SPRecursiveRewrite ] :=
  110.     { Dialogue -> False, MaxRecursion -> $RecursionLimit }
  111.  
  112. SPRecursiveRewrite[e_, rules_, options___] :=
  113.     Block [    {dialogue, difference = True, iteration = 0, maxiterations,
  114.          newexpr, oldexpr, oplist},
  115.         oplist = ToList[options] ~Join~ Options[SPRecursiveRewrite];
  116.         dialogue = InformUserQ[ oplist ];
  117.         maxiterations = Replace[ MaxRecursion, oplist];
  118.         If [ ! ( IntegerQ[maxiterations] && maxiterations > 0 ),
  119.              maxiterations = $RecursionLimit;
  120.              Message[ SPRecursiveRewrite::badrec, maxiterations ] ];
  121.  
  122.         newexpr = e;
  123.         If [ dialogue, Print[e] ];
  124.         While [ difference && iteration < maxiterations,
  125.             iteration++;
  126.             oldexpr = newexpr;
  127.             newexpr = Replace[oldexpr, rules];
  128.             difference = ! SameQ[oldexpr, newexpr];
  129.             If [ difference && dialogue,
  130.                  Print["which becomes"]; Print[newexpr] ] ];
  131.  
  132.         newexpr ]
  133.  
  134.  
  135. (*  I N T E L L I G E N T  L Y     A P P L Y I N G     R U L E S  *)
  136.  
  137. SPRecursiveRewrite::badrec =
  138. "The MaxRecursion option is not set to a positive integer--- `` will be used."
  139.  
  140. Options[ SPHeuristicRewrite ] :=
  141.     { Dialogue -> False, MaxRecursion -> $RecursionLimit }
  142.  
  143. SPHeuristicRewrite[expr_, rules_, options___] :=
  144.     Block [    {dialogue, difference = True, iteration = 0, maxiterations,
  145.          newexpr, oldexpr, oplist},
  146.         oplist = ToList[options] ~Join~ Options[SPHeuristicRewrite];
  147.         dialogue = InformUserQ[ oplist ];
  148.         maxiterations = Replace[ MaxRecursion, oplist ];
  149.         If [ ! ( IntegerQ[maxiterations] && maxiterations > 0 ),
  150.              maxiterations = $RecursionLimit;
  151.              Message[ SPRecursiveRewrite::badrec, maxiterations ] ];
  152.  
  153.         RuleList = rules;        (* global to package *)
  154.         heuristicrewrite[ expr, maxiterations,
  155.                   dialogue, 0, Depth[expr] ] ]
  156.  
  157. heuristicrewrite[expr_, maxi_, dialogue_, level_, stoplevel_] :=
  158.     expr /;
  159.     AtomQ[expr] || ( maxi <= 0 ) || SameQ[level, stoplevel]
  160.  
  161. heuristicrewrite[expr_, maxi_, dialogue_, level_, stoplevel_] :=
  162.     heuristicrewrite[expr, maxi, dialogue, 0, stoplevel] /;
  163.     level >= Depth[expr]
  164.  
  165. heuristicrewrite[expr_, maxi_, dialogue_, level_, stoplevel_] :=
  166.     Block [    {applyflag, curnode, currule, funp, newlist = {}, nextlevel,
  167.          node, nodelist, norulesapplied, numnodes, numrules, rule},
  168.  
  169.         nextlevel = level + 1;
  170.  
  171.         (* For each rule,                    *)
  172.         (*   If the rule applies to all of the children of at    *)
  173.         (*      least one node at level level            *)
  174.         (*   Then apply the rule to the children of every node    *)
  175.         (*        if the rule applies to all of the children    *)
  176.         (*        add the new expression to newlist        *)
  177.  
  178.         nodelist = Level[expr, {level}];
  179.         numnodes = Length[nodelist];
  180.         numrules = Length[RuleList];
  181.         For [ rule = 1, rule <= numrules, rule++,
  182.               currule = RuleList[[rule]];
  183.               applyflag = False;
  184.               For [ node = 1, node <= numnodes, node++,
  185.                 curnode = nodelist[[node]];
  186.                 If [ RuleAppliesQ[curnode, currule, True],
  187.                  applyflag = True; Break[] ] ];
  188.               If [ applyflag,
  189.                AppendTo[ newlist,
  190.                      Map[ applytochildren[#, currule]&,
  191.                       expr,
  192.                       {level} ] ] ] ];
  193.  
  194.         (* If no rules were applied to level level of expr,    *)
  195.         (* Then try the next level of the expression        *)
  196.         (* Else try the next level of each new expression    *)
  197.  
  198.         norulesapplied = EmptyQ[newlist];
  199.         If [ norulesapplied,
  200.              heuristicrewrite[ expr, maxi - 1,
  201.                        dialogue, nextlevel, stoplevel ],
  202.  
  203.              funp = heuristicrewrite[ #, maxi - 1, dialogue,
  204.                                nextlevel, level ]&;
  205.              Prepend[Map[funp, newlist], expr] ] ]
  206.  
  207.  
  208. applytochildren[ node_, rule_ ] := node /; AtomQ[node]
  209. applytochildren[ h_[e1_, rest___], rule_ ] :=
  210.     Apply[ h, Map[ Replace[#, rule]&, {e1, rest} ] ] /;
  211.     RuleAppliesQ[ h[e1, rest], rule, True ]
  212. applytochildren[ node_, rule_ ] := node 
  213.  
  214.  
  215. (*  E N D     P A C K A G E  *)
  216.  
  217. End[]
  218. EndPackage[]
  219.  
  220. If [ TrueQ[ $VersionNumber >= 2.0 ],
  221.      On[ General::spell ];
  222.      On[ General::spell1 ] ];
  223.  
  224.  
  225. (*  W R I T E     P R O T E C T I O N  *)
  226.  
  227. Block [    {newfuns},
  228.     newfuns = { SPHeuristicRewrite, SPRecursiveRewrite };
  229.     Combine[ SPfunctions, newfuns ];
  230.     Apply[ Protect, newfuns ] ]
  231.  
  232.  
  233. (*  E N D I N G     M E S S A G E  *)
  234.  
  235. Print["System rewrite rules have been loaded."]
  236. Null
  237.